home *** CD-ROM | disk | FTP | other *** search
/ PC-SIG Library 8 / PC-SIG Library CD-ROM (8th Edition) (1990-04).iso / 001_100 / disk0074 / demog.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1983-07-06  |  15.9 KB  |  529 lines
  1. {(C) Copyright Software Labs. 1982 }
  2. {$include:'b:demog.inc'}    {this line is not in the listing of the manual }
  3. {$include:'b:gunit.inc'}
  4. { Demog.pas - graphics, music, scrolling demo for the Pascal Utilities }
  5. { Draw a pie, bar, and line charts and a moving logo and graphics cursor}
  6.  
  7. implementation of demogunit;
  8. USES SoftwareLabsg(initgunit, window, viewport,draw,move,cursor,
  9.     cursorc, circlg, pie, bar);
  10.  
  11. {$include:'b:plib.inc'}
  12. {$include:'b:glib.inc'}
  13. {$include:'b:alib.inc'}
  14. {$include:'b:slib.inc'}
  15. {$debug-}
  16. procedure demog;
  17.  
  18. { these constant divide the screen into three viewport }
  19. const ymax=199; xmax=319; ysep1=49; xsep2=150;ysep2=119;sharesize=10;
  20.       sinesize = xmax-xsep2-1;    pitime2=6.28319;
  21.  
  22. var share : array [1..sharesize] of integer; sum, maxshare, lastshare : integer;
  23.     sine : array[ 0 .. sinesize] of real;
  24.     ls : lstring(80); picrab : array[0 .. 1 ] of string(616);     {stores rabbit}
  25.               pictur : array[0 .. 1 ] of string(392);     {stores turtle}
  26.     ch : char; i, scan, mode, page, numcol : integer;
  27.     musicnum : integer;                      {0 if no music }
  28.  
  29.  
  30. {***** playmusic - plays music }
  31. procedure playmusic;
  32. const
  33.   lastsong = 4;
  34. type
  35.   stype = array[ 1 .. lastsong ] of lstring(100);
  36. var
  37.   s1[static] : stype;    s2[static] : stype;  s3[static] : stype;
  38. value
  39.  {Yankee DooDo}
  40.  S1[1]:='11231325|1123175|11234321|756711|6.7656716|5.654345|6.7656716|517211|';
  41.  S2[1]:='-------- ---- -- -------- ----   - =------ - =----  - =------ ----   ';
  42.  S3[1]:='^^^^^^^  ^^^^^   ^^^^^^^^     ^^        ^                  ^   ^ ^^^ ';
  43.  
  44.  {Humourous part 1}
  45.  S1[2]:='1.21.23.56.51.72.17.21.65.56.51.65.32---';
  46.  S2[2]:='- =- =- =- =- =- =- =- =- =- =- =- =    ';
  47.  S3[2]:='^ ^^ ^^ ^^ ^~ ^~ ~^ ~~ ^^ ^^ ^~ ^^ ^^   ';
  48.  
  49.  {Humourous part 2}
  50.  S1[3]:='1.21.23.56.56.72.17.21.65.53.5 4.32.61---';
  51.  S2[3]:='- =- =- =- =- =- =- =- =- =- = - =- =    ';
  52.  S3[3]:='^ ^^ ^^ ^^ ^^ ^~ ~^ ~~ ^^ ^~ ^ ^ ~~ ^~   ';
  53.  
  54.  {Go Hell}
  55.  S1[4]:='312312342342345634123215-312312342342345634123.5321-113535---';
  56.  S2[4]:=' ------ ------  ---- --   ------ ------  ----- =--   --      ';
  57.  S3[4]:='                                                    ~~~~~~   ';
  58. begin
  59.      { musicnum = 0 for no music, otherwise the current music }
  60.      if musicnum > 0 then        { need music }
  61.        if not musicon then begin    { check if music stops }
  62.      if musicnum >= lastsong then
  63.        musicnum := 1
  64.      else
  65.        musicnum := musicnum + 1;
  66.      musicload('F',1,s1[musicnum ], s2[musicnum], s3[musicnum]);
  67.      musicgo;
  68.        end;
  69. end; {playmusic}
  70.  
  71.  
  72.  
  73.  
  74.  
  75. { ***** asksharedata - enter share data; find maximum and total }
  76. procedure asksharedata;
  77. var i, sinesized4, sinesized2, j : integer; angle,angleinc,  sinedata : real;
  78. begin
  79.   locate(0,0,0); putlstring( 0,7,'Loading data');
  80.   { assign share data }
  81.   share[1] := 15; share[2] := 18; share[3] := 6; share[4] := 14;
  82.   share[5] := 9;  share[6] := 14; share[7] := 20; share[8] := 14;
  83.   lastshare := 8;    maxshare := 0; sum:= 0; { initialize to find size and max}
  84.   for i := 1 to lastshare do begin
  85.    sum := sum+share[i];
  86.    if share[i] > maxshare then maxshare := share[i]
  87.   end;
  88.   { loading data for sine chart }
  89.   angle := 0; sinesized2 := sinesize div 2; sinesized4 := sinesize div 4;
  90.   angleinc := pitime2 / sinesize;   j := sinesized4;
  91.   for i := 1 to j do begin
  92.     if inkey( ch, scan ) then return;         { return if any key is pressed}
  93.     sinedata := sin(angle); sine[i] := sinedata; sine[sinesized2-i] := sinedata;
  94.     sine[sinesized2+i] := -sinedata; sine[sinesize-i] := -sinedata;
  95.     angle := angle+angleinc;
  96.   end;
  97.   locate(0,0,0); putlstring( 0,7,'            ');
  98. end; { asksharedata }
  99.  
  100.  
  101.  
  102.  
  103. { ***** piechart - plot pie chart for share data }
  104. procedure piechart;
  105. const  piestartangle = 0.14;
  106. var i,j: integer; sangle,eangle, scale, angle : real;
  107. begin
  108.   locate(0,0,0);
  109.   viewport(0, ysep1, xsep2, ymax);
  110.   window( -1.0, -1.0, 1.0, 1.0); { a unit window for pie }
  111.   scale := pitime2/sum;  sangle := piestartangle; { starting angle for pie }
  112.   eangle:=scale*share[1] + sangle;
  113.   { pull out the first pie }
  114.   angle := ( sangle + eangle)/2;
  115.   pie(0.18*cos(angle), 0.18*sin(angle), 0.6,0.6, sangle, eangle, 1,2,1);
  116.   for i := 2 to lastshare do begin
  117.    if inkey( ch, scan ) then return;        { return if any key is pressed}
  118.    sangle:=eangle;    eangle:= scale*share[i]+sangle;
  119.    pie(0.0, 0.0, 0.6,0.6, sangle, eangle, 3,1,i);  {use i as the pattern}
  120.    playmusic;
  121.   end;
  122. end; { piechart }
  123.  
  124.  
  125.  
  126.  
  127.  
  128. { ***** barchart - plot bar chart for share data }
  129. procedure barchart;
  130. const patstart = 14;
  131. var i : integer; xinc, yscale,x1,x2 : real;
  132. begin
  133.   viewport( xsep2,ysep2, xmax, ymax);
  134.   window( 0.0, 0.0 , 1.0, 1.0); { a unit window for bar}
  135.   move(0.1,0.9); draw(0.1, 0.1,3); draw(0.9, 0.1, 3); { axis }
  136.   xinc := (0.8-0.1)/lastshare; yscale := (0.8-0.1)/maxshare; x1 := 0.15;
  137.   for i := 1 to lastshare do begin
  138.     if inkey( ch, scan ) then return;         { return if any key is pressed}
  139.     playmusic;
  140.     x2 := x1 + xinc;
  141.     bar(x1,0.1, x2, yscale*share[i], 1,2, i+patstart);
  142.     x1 := x2;
  143.   end;
  144. end; { barchart }
  145.  
  146.  
  147.  
  148.  
  149. { ***** linechart - plot a sine and  a cosine graph }
  150. procedure linechart;
  151. var i,j, lasti : integer; xinc,x1, angleinc, angle: real;
  152. begin
  153.   viewport( xsep2,ysep1, xmax, ysep2);
  154.   window(-0.1,    -1.1 , 1.1, 1.1); { a unit window for bar}
  155.   move(0.0, 1.0); draw(0.0, -1.0,2); draw(1.0,-1.0, 2); { axis }
  156.   { plot a sine curve }
  157.   {lasti := round(xmax-xsep2); xinc := 1.0/lasti;  x1 := 0.0;
  158.   angleinc := 2.0*pi/lasti; angle := 0; move(x1, sin(angle));
  159.   for i := 1 to lasti do begin
  160.     x1 := x1+xinc; angle := angle+angleinc;  draw(x1, sin(angle),1) end;}
  161.  
  162.   xinc := 1.0/sinesize; x1 := 0.0; i := 1;  move(x1, sine[i]);
  163.   for i := 1 to sinesize  do begin
  164.    playmusic;
  165.    if inkey( ch, scan ) then return;        { return if any key is pressed}
  166.    x1 := x1 +xinc;
  167.    draw(x1,sine[i],3)
  168.   end;
  169.   { plot a cosine with double frequency }
  170.   x1 := 0.0; j := sinesize div 4;  move(x1, sine[j]);
  171.   for i := 1 to sinesize  do begin
  172.    if inkey( ch, scan ) then return;        { return if any key is pressed}
  173.    playmusic;
  174.    x1 := x1 +xinc; j:=j+2;
  175.    if j >= sinesize then j := 1;
  176.    draw(x1,sine[j],1)
  177.   end;
  178. end; { linechart }
  179.  
  180.  
  181.  
  182.  
  183. {**** createrabbit - create a rabbit using the screen }
  184. procedure createrabbit;
  185. begin
  186.   {head with an open mouth}
  187.   view(0,0,319,199);
  188.   circle(16,16,15,16,2, -355, -315);       {head }
  189.   circle(20,24,4,3,2, 0,360);           {open eye}
  190.   paint(10, 16, 3, 2, 1);
  191.   {left ear}
  192.   circle(56,36,50,50,2, 143,189);
  193.   circle(-32,52,50,50,2, 336,16);
  194.   paint(16,40,1,2,4);
  195.   {right ear}
  196.   circle(56,24,50,50,2,126,140);
  197.   circle(-24,60,50,50,2, 326,5);
  198.   paint(20,48,1,2,4);
  199.   getpic(0,0,32,65,picrab[0]);
  200.   putpic(0,0,0,picrab[0]);       {erase the original picture}
  201.   {head with a closed mouth}
  202.   circle(16,16,15,16,2,  -355, -350);
  203.   drawline(16,24,24,24,2);    {closed eye}
  204.   paint(10, 16, 3, 2, 1);
  205.   {left ear}
  206.   circle(56,36,50,50,2, 143,189);
  207.   circle(-32,52,50,50,2, 336,16);
  208.   paint(16,40,1,2,4);
  209.   {right ear}
  210.   circle(56,24,50,50,2,126,140);
  211.   circle(-24,60,50,50,2,326,5);
  212.   paint(20,48,1,2,4);
  213.   getpic(0,0,32,67,picrab[1]);
  214.   putpic(0,0,0,picrab[1]);       {erase the original picture}
  215. end; {createrabbit}
  216.  
  217.  
  218.  
  219. {*****creatturtle - create a turtle using the screen }
  220. procedure createturtle;
  221. begin
  222.   circle(22,16,18,10,3, 0,360); {body}
  223.   paint(22,16,2,3, 10);
  224.   circle(22,16,22,6,3,350,10);    {head}
  225.   circle(24,24,8,8,3,0,45);    {left hand }
  226.   circle(4,24,8,8,3,0,45);    {left foot}
  227.   circle(4,8,8,8,3,315,360);    {right foot}
  228.   circle(24,8 ,8,8,3,315,360);    {right hand}
  229.   circle(8,8,8,8,3,90, 135);    {tail }
  230.   getpic(0,0, 44,31, pictur[0]);{store it}
  231.   circle(8,8,8,8,128+3,90, 135);{erase tail }
  232.   circle(8,24,8,8,3,180 , 225); { new tail }
  233.   getpic(0,0, 44,31, pictur[1]);{store it}
  234.   putpic(0,0,0,  pictur[1]);       {erase it from the screen}
  235. end; { createturtle }
  236.  
  237.  
  238.  
  239.  
  240. {****** use the next  palette }
  241. procedure nextpalette(var palettenum, bcolor : integer);
  242. begin
  243.   if bcolor >= 15 then begin
  244.     if palettenum = 0 then     { change palette }
  245.       palettenum := 1
  246.     else
  247.       palettenum := 0;
  248.     bcolor := 0;
  249.   end
  250.   else
  251.     bcolor := bcolor + 1;
  252.   palette( palettenum, bcolor);
  253.   locate(0,20,0);
  254.   write('Palette number =',palettenum:1,'    Background=',bcolor:2);
  255. end; {next palette }
  256.  
  257.  
  258.  
  259. { ***** moving - moves a logo along the x axis }
  260. procedure moving;
  261. const logoy=50; gxstart = 0;
  262. var gx,nx,                { rabbit  x positions current and new }
  263.     gtx, ntx, gty, nty,         {turtle  position  }
  264.     gcx,gcy,                {cursor positions }
  265.     scan,ni,gi,count,palettenum,bcolor:integer;ch:char;
  266.     withjoystick : boolean;        { if it has a joystick, it controls the
  267.                       graphics cursor, otherwise the graphics
  268.                       cursor use the same x postion for logo,
  269.                       and use a random number for y position}
  270.     ax,ay,bx,by,a1,a2,b1,b2 : integer; {joystick }
  271. begin { moving }
  272.   view(0,0, 319,199);
  273.   if numgame > 0 then
  274.     withjoystick := true
  275.   else
  276.     withjoystick := false;
  277.   gx:=gxstart;     gi:=0; gtx := gxstart; gty:= 150; { initialization }
  278.   putpic(gx,logoy,0,picrab[gi]);
  279.   putpic(gtx,gty,0, pictur[gi]);
  280.   palettenum := 0; bcolor := 0;
  281.  
  282.   while not inkey( ch, scan ) do begin
  283.  
  284.    { new position for turtle }
  285.  
  286.    if withjoystick then begin
  287.      joystick(ax,ay,bx,by,a1,a2,b1,b2);
  288.      if ax =  25 then withjoystick := false;     { user unplug it ; use random}
  289.      if ax >= 10 then begin
  290.     if gtx + 10 < 270 then            { limit in bound }
  291.       ntx := gtx + 10
  292.     else
  293.       ntx := 0;
  294.      end
  295.      else if ax <= 6 then begin
  296.        if gtx - 10 >= 0 then
  297.     ntx := gtx - 10;
  298.      end
  299.      if ay >= 11 then begin
  300.     if gty + 10 <= 165 then
  301.     nty := gty + 7
  302.      end
  303.      else if ay  <= 7 then
  304.        if gty - 10 >= 0 then
  305.     nty := gty - 7;
  306.    end;        { with joystick }
  307.    if ntx >= 270 then
  308.        ntx := 0
  309.    else
  310.        ntx := ntx + 1;
  311.  
  312.    { new x position for rabbit }
  313.    if gx >= 300 then begin             { touch the right boundary}
  314.      nx := gxstart;                  { from leftmost }
  315.      nextpalette(palettenum, bcolor);
  316.    end
  317.    else                      { moving to the right }
  318.      nx := gx + 4;
  319.  
  320.  
  321.    { new y position for the graphics cursor  from random number }
  322.    gcy := rnd mod 200;                  {returns 0 to 199 }
  323.  
  324.    { which pattern to use for the rabbit }
  325.    if gi = 0 then
  326.      ni := 1
  327.    else
  328.      ni := 0;
  329.  
  330.    { now move to the new position }
  331.    cursorg(ntx,gcy);                {move the graphics cursor}
  332.    putpic(gx, logoy, 0, picrab[gi]);        {erase the previous picture}
  333.    putpic(nx, logoy, 0, picrab[ni]);        {create new object}
  334.    putpic(gtx,    gty, 0, pictur[gi]);        {erase the previous picture}
  335.    putpic(ntx,    nty, 0, pictur[ni]);        {create new object}
  336.    gx := nx;    gi := ni;  gtx := ntx; gty := nty;    {new items}
  337.    playmusic;
  338.   end;                        {while }
  339. end; { moving }
  340.  
  341.  
  342.  
  343.  
  344. { ***** message - print copyright and instruction }
  345. procedure message;
  346. const  intensity=15;
  347. begin
  348.   locate(0,24,2);
  349.   putlstring(0,2,'(C)Copyright Software Labs 1983');
  350.   locate(0,22,7);
  351.   putlstring(0,intensity,'Presse any key to exit');
  352.   locate(0,23,0);
  353.   putlstring(0,intensity,'Pascal Utilities  by Software Labs');
  354. end; { message }
  355.  
  356.  
  357.  
  358. { ***** demographics - demo pie, bar, line and moving object }
  359. procedure demographics;
  360. begin
  361.   asksharedata;
  362.   piechart;
  363.   barchart;
  364.   linechart;
  365.   moving;
  366. end; { demographics }
  367.  
  368.  
  369.  
  370.  
  371.  
  372. {******selectmusic - ask whether the user need background music }
  373. procedure selectmusic;
  374. begin
  375.   putlstring(0,2,'background music (y/n) ? ');
  376.   while not inkey (ch, scan ) do { do nothing }  ;
  377.   if ( ch = 'y' ) or ( ch = 'Y') then begin
  378.      musicinit;                       {initialize music}
  379.      musicnum := 1;
  380.      playmusic;
  381.   end;
  382. end;
  383.  
  384.  
  385.  
  386. { ***** demopattern - display all the patterns }
  387. procedure demopattern;
  388. const  rsize = 4; csize = 10; xsize=24; ysize=24; xstart=50; yend=170;
  389.        ystart=74; xend=290; qnumlock=69;
  390. var
  391.   x,y,row, col,  pattern, bcolor, palettenum, count: integer;
  392. begin
  393.   locate(0,0,14);
  394.   putlstring(0, 2, 'Pattern Tables');
  395.   {print lables }
  396.   locate(0, 2, 7);
  397.   putlstring(0, 1, '0  1  2  3  4  5  6  7  8  9');       { vertical label }
  398.   locate(0,5,4); putchar(0, 1, 1, '0');                   { horizontal label }
  399.   locate(0,8,4); putchar(0, 1, 1, '1');
  400.   locate(0,11,4); putchar(0, 1, 1, '2');
  401.   locate(0,14,4); putchar(0, 1, 1, '3');
  402.   { grid}
  403.   x := xstart;
  404.   while x <= xend do begin
  405.     if inkey( ch, scan ) then return;         { return if any key is pressed}
  406.     drawline(x, ystart, x, yend, 3);
  407.     x := x + xsize;
  408.   end;
  409.   y := ystart;
  410.   while y <= yend do begin
  411.     if inkey( ch, scan ) then return;         { return if any key is pressed}
  412.     drawline(xstart, y, xend, y, 3);
  413.     y := y + ysize;
  414.   end;
  415.   { paint each box by puting a seed }
  416.   pattern := 0;
  417.   y := yend - 4;
  418.   for row := 1 to rsize do begin
  419.     x := xstart+4;
  420.     for col := 1 to csize do begin
  421.       if inkey( ch, scan ) then return;        { return if any key is pressed}
  422.       paint(x, y, 2, 3, pattern);    { interior color= 2; boundary = 3}
  423.       pattern := pattern+1;
  424.       x := x + xsize;
  425.       playmusic;
  426.     end;
  427.     y := y-ysize;            { for the next y }
  428.   end;
  429.   palettenum := 0; bcolor := 0;
  430.   while not inkey(ch, scan) do
  431.     { delay until a key is pressed; chage palette when count reach 1000 }
  432.     if count < 2000 then begin
  433.       playmusic;
  434.       count := count + 1
  435.       end
  436.     else begin
  437.       count := 0;
  438.       nextpalette(palettenum,bcolor);
  439.     end;
  440.   if scan = qnumlock then readln(ch);  {freeze it untill a key is pressed }
  441. end;  { demopattern}
  442.  
  443.  
  444.  
  445.  
  446.  
  447. {***** demoscreen - demostrate scroll and music }
  448. procedure demoscreen(mode : integer);
  449. const
  450.   lastmsg   = 10;  trow=11; brow=21;
  451. var
  452.   nextmsg, key: integer;
  453.   msg[static] : array[0..lastmsg] of lstring(40);
  454.  
  455. value
  456.   msg[0] := 'Yes, this demo program is written in DOS';
  457.   msg[1] := 'Pascal calling the Pascal Utilities.    ';
  458.   msg[2] := 'The following scrolling messages are:   ';
  459.   msg[3] := 'You don not have to worry the effifiency';
  460.   msg[4] := 'of the Pascal Utilities.   It is written';
  461.   msg[5] := 'in Macro Assembly Language calling BIOS.';
  462.   msg[6] := 'Efficient  algorithms  control   screen,';
  463.   msg[7] := 'keyboard,  graphics,  music,  joysticks,';
  464.   msg[8] := 'lightpen,  communication (RS232)  ports,';
  465.   msg[9] := 'and equipments.  It controls a  PC  from';
  466.   msg[10]:= 'inside your Pascal programs.            ';
  467.  
  468. begin
  469.   screen(mode);
  470.   selectmusic;
  471.   screen(mode);
  472.   { print the static message }
  473.   for nextmsg := 0 to lastmsg do begin
  474.     locate(0, nextmsg, 0);
  475.     putlstring(0, 2, msg[nextmsg]);
  476.   end;
  477.   { scroll messages }
  478.   message;
  479.   nextmsg := lastmsg;
  480.   while not inkey( ch, scan) do         { while no key is pressed}
  481.   begin                     { display messages }
  482.     { rotating using the message }
  483.     if nextmsg >= lastmsg then        { rotate the displaying message }
  484.       nextmsg := 0
  485.     else
  486.       nextmsg := nextmsg + 1;
  487.     scroll('U', 1, trow, 0, brow, 39, 2);         { scroll the message }
  488.     locate(0, brow, 0);
  489.     putlstring(0, 2, msg[nextmsg]);          {new message}
  490.     playmusic;
  491.   end;
  492. end; { demoscreen }
  493.  
  494.  
  495.  
  496.  
  497. begin { main }
  498.    musicnum := 0;
  499.    mode := screenmode( page, numcol);
  500.    screen(mode);
  501.    writeln('Selects Graphics or Screen demo');
  502.    putlstring(0,2,'Enter "G" or "S" > ');
  503.    while not inkey(ch, scan ) do  { do nothing } ;
  504.    if ( ch <> 'G' ) and ( ch <> 'g' ) then
  505.      demoscreen(mode)
  506.    else                           { graphics demo }
  507.     if mode = 7 then begin                   {monochrome monitor}
  508.      screeng(mode);
  509.      putlstring(0,1,'Graphics Demo Cannot run without Graphics/Color Adapter');
  510.     end
  511.     else  begin
  512.      initgunit(4); { mode 4 : 320*200 color; 5 : 320*200 B/W; 6: 640*320 B/W}
  513.      selectmusic;                   { select background music }
  514.      screeng(4);
  515.      message;
  516.      demopattern;
  517.      screeng(4);
  518.      palette(0,1);
  519.      createrabbit;
  520.      createturtle;
  521.      message;
  522.      demographics;
  523.     end;
  524.   screen( mode);
  525.   if musicnum > 0 then    musicstop;
  526. end;
  527. begin
  528. end.
  529.